home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp16.arc / INIT.LSP < prev    next >
Text File  |  1986-01-06  |  2KB  |  76 lines
  1. ; initialization file for XLISP 1.6
  2.  
  3. ; get some more memory
  4. (expand 1)
  5.  
  6. ; some fake definitions for Common Lisp pseudo compatiblity
  7. (setq first  car)
  8. (setq second cadr)
  9. (setq rest   cdr)
  10.  
  11. ; (when test code...) - execute code when test is true
  12. (defmacro when (test &rest code)
  13.           `(cond (,test ,@code)))
  14.  
  15. ; (unless test code...) - execute code unless test is true
  16. (defmacro unless (test &rest code)
  17.           `(cond ((not ,test) ,@code)))
  18.  
  19. ; (makunbound sym) - make a symbol be unbound
  20. (defun makunbound (sym) (setq sym '*unbound*) sym)
  21.  
  22. ; (objectp expr) - object predicate
  23. (defun objectp (x) (eq (type-of x) :OBJECT))
  24.  
  25. ; (filep expr) - file predicate
  26. (defun filep (x) (eq (type-of x) :FILE))
  27.  
  28. ; (unintern sym) - remove a symbol from the oblist
  29. (defun unintern (sym) (cond ((member sym *oblist*)
  30.                              (setq *oblist* (delete sym *oblist*))
  31.                              t)
  32.                             (t nil)))
  33.  
  34. ; (mapcan fun list [ list ]...)
  35. (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
  36.  
  37. ; (mapcon fun list [ list ]...)
  38. (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
  39.  
  40. ; (set-macro-character ch fun [ tflag ])
  41. (defun set-macro-character (ch fun &optional tflag)
  42.     (setf (aref *readtable ch) (cons (if tflag :tmacro :nmacro) fun))
  43.     t)
  44.  
  45. ; (get-macro-character ch)
  46. (defun get-macro-character (ch)
  47.   (if (consp (aref *readtable* ch))
  48.     (cdr (aref *readtable* ch))
  49.     nil))
  50.  
  51. ; (save fun) - save a function definition to a file
  52. (defmacro save (fun)
  53.          `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
  54.                  (fval (car ,fun))
  55.                  (fp (openo fname)))
  56.                 (cond (fp (print (cons (if (eq (car fval) 'lambda)
  57.                                            'defun
  58.                                            'defmacro)
  59.                                        (cons ',fun (cdr fval))) fp)
  60.                           (close fp)
  61.                           fname)
  62.                       (t nil))))
  63.  
  64. ; (debug) - enable debug breaks
  65. (defun debug ()
  66.        (setq *breakenable* t))
  67.  
  68. ; (nodebug) - disable debug breaks
  69. (defun nodebug ()
  70.        (setq *breakenable* nil))
  71.  
  72. ; initialize to enable breaks but no trace back
  73. (setq *breakenable* t)
  74. (setq *tracenable* nil)
  75.  
  76.